perm filename TRANSF.OLD[IRC,LCS] blob
sn#641764 filedate 1982-02-15 generic text, type T, neo UTF8
00100 C READS IN TWO FILES FOR TRANSFORMATION
00200 IMPLICIT INTEGER (X-Z)
00300 DIMENSION RN(3)
00400 C RN WILL HOLD FILE NAMES
00500 COMMON /A/X1(700),Y1(700),Z1(700),K1
00600 COMMON /B/X2(700),Y2(700),Z2(700),K2
00700 COMMON /C/X3(700),Y3(700),Z3(700),K3
00800 CALL READX(1)
00900 CALL READX(2)
01000 IF(K1.LT.K2)GO TO 1
01100 CALL REVERS
01200 1 CALL EQUALO
01300 C ASSUMES OUTLINE IS FIRST LONG CONTINUOUS LINE.
01400 C FIRST EQUALIZES OUTLINE, THEN THE REST
01500 CALL EQUALZ
01600 2 CALL PRCNTQ
01700 CALL OUTPUT
01800 C GO TO 2
01900 100 END
02000
02100 SUBROUTINE EQUALO
02200 COMMON /A/X1(700),Y1(700),Z1(700),K1
02300 COMMON /B/X2(700),Y2(700),Z2(700),K2
02400 COMMON /C/X3(700),Y3(700),Z3(700),K3
02450 COMMON /JO/JOUT1,JOUT2
02500 JOUT1=K1
02600 CALL FINDO(Z1,JOUT1)
02700 JOUT2=K2
02800 CALL FINDO(Z2,JOUT2)
02900 A=JOUT1
03000 B=JOUT2
03100 C=A/B
03200 C C SHOULD BE < OR = TO 1
03300 100 A=1
03400 DO 1 K=1,JOUT2
03500 K3=A+.5
03600 X3(K)=X1(K3)
03700 Y3(K)=Y1(K3)
03800 Z3(K)=Z1(K3)
03900 1 A=A+C
04000 C NOW ARRAY C HAS SAME NUMB. OF OUTLINE POINTS AS B.
04100 K3=JOUT2
04200 200 END
04300
04400 SUBROUTINE EQUALZ
04500 COMMON /A/X1(700),Y1(700),Z1(700),K1
04600 COMMON /B/X2(700),Y2(700),Z2(700),K2
04700 COMMON /C/X3(700),Y3(700),Z3(700),K3
04750 COMMON /JO/JOUT1,JOUT2
05200 A=K1-JOUT1
05300 B=K2-JOUT2
05400 C=A/B
05500 C C SHOULD BE < OR = TO 1
05600 A=JOUT1+1
05700 DO 1 K=K3+1,K2
05800 N=A+.5
05900 X3(K)=X1(N)
06000 Y3(K)=Y1(N)
06100 Z3(K)=Z1(N)
06200 1 A=A+C
06300 C NOW REST OF ARRAY C HAS SAME NUMB. OF POINTS AS B.
06400
06500 C BALANCE UP SOME OF THE VISIBLE-INVISIBLE MARKERS
06600 DO 2 K=K3+1,K2
06700 IF(X3(K).NE.X3(K-1))GO TO 2
06800 IF(Y3(K).NE.Y3(K-1))GO TO 2
06900 IF(Z3(K).NE.Z3(K-1))GO TO 2
07000 Z3(K)=Z2(K)
07100 Z3(K-1)=Z2(K-1)
07200 2 CONTINUE
07300 END
07900 SUBROUTINE PRCNTQ
07950 IMPLICIT INTEGER (X-Z)
08000 COMMON /A/X1(700),Y1(700),Z1(700),K1
08100 COMMON /B/X2(700),Y2(700),Z2(700),K2
08200 COMMON /C/X3(700),Y3(700),Z3(700),K3
08300 10 FORMAT(' TYPE PERCENT OF TRANSFORMATION (.5=50%) ')
08400 11 FORMAT(F)
08500 TYPE 10
08600 ACCEPT 11,P
08800 DO 1 K=1,K2
10200 A=X2(K)-X3(K)
10300 A=A*P+.5
10400 B=Y2(K)-Y3(K)
10500 B=B*P+.5
10600 X3(K)=X3(K)+A
10700 1 Y3(K)=Y3(K)+B
12000 L=1
12100 DO 5 K=1,K2
12200 IF(Z3(K).EQ.Z2(K))GO TO 3
12300 A=X3(K+1)-X3(K)
12400 B=Y3(K+1)-Y3(K)
12500 IF(Z3(K).EQ.0)GO TO 2
12600 C NOW Z3=1 AND Z2=0
12700 A=A*P+.5
12800 B=B*P+.5
12900 Z1(L)=0
13000 4 X1(L)=X3(K)+A
13100 Y1(L)=Y3(K)+B
13200 L=L+1
13300 GO TO 3
13400 2 C=1.-P
13500 A=A*C+.5
13600 B=B*C+.5
13700 Z1(L)=1
13800 GO TO 4
14300 3 X1(L)=X3(K)
14400 Y1(L)=Y3(K)
14500 Z1(L)=Z3(K)
14600 L=L+1
14700 5 CONTINUE
14800 K1=L-1
14900 END